home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 27 / CU Amiga Magazine's Super CD-ROM 27 (1998)(EMAP Images)(GB)[!][issue 1998-10].iso / CUCD / Programming / JForth / Extras / SysGen / c_struct < prev    next >
Encoding:
Text File  |  1992-01-22  |  8.6 KB  |  316 lines
  1. \ STRUCTUREs are for interfacing with 'C' programs.
  2. \ Structures are created using :STRUCT and ;STRUCT
  3. \
  4. \ This file must be loaded before loading any .J files.
  5. \
  6. \ Author: Phil Burk
  7. \ Copyright 1986 Phil Burk
  8. \
  9. \ MOD: PLB 1/16/87 Use abort" instead of er.report
  10. \      MDH 4/14/87 Added sign-extend words to ..@
  11. \ MOD: PLB 9/1/87 Add pointer to last member for debug.
  12. \ MOD: MDH 4/30/88 Use fast addressing for ..@ and ..!
  13. \ MOD: PLB/MDH 9/30/88 Fixed offsets for 16@+long and 8@+long
  14. \        fixed OB.COMPILE.+@/! for 0 offset
  15. \ MOD: PLB 1/11/89 Added EVEN-UP in case of last member BYTE
  16. \ MOD: PLB 2/23/90 ADD S@ and S! for auto >ABS and >REL
  17. \ MOD: PLB 7/18/90 Added IF>ABS to !BYTES
  18. \
  19. \ 00001 14-may-90 mdh LoadJForth files now in jf:
  20. \ 00002 PLB 11/19/91 Add TAIL to >ABS32!+LONG and >ABS32!+BYTE
  21. \ 00003 PLB/MDH 1/22/92 Use $ERROR instead of ABORT
  22.  
  23. INCLUDE? OB.MAKE.MEMBER jf:MEMBER
  24.  
  25. ANEW TASK-C_STRUCT
  26.  
  27. \ STRUCT ======================================================
  28. : <:STRUCT> ( pfa -- , run time action for a structure)
  29.     [COMPILE] CREATE  
  30.         @ even-up here swap dup ( -- here # # )
  31.         allot  ( make room for ivars )
  32.         erase  ( initialize to zero )
  33. ;
  34.  
  35. \ Contents of a structure definition.
  36. \    CELL 0 = size of instantiated structures
  37. \    CELL 1 = #bytes to last member name in dictionary.
  38. \             this is relative so it will work with structure
  39. \             relocation schemes like MODULE
  40.  
  41. : :STRUCT (  -- , Create a 'C' structure )
  42. \ Check pairs
  43.    ob-state @
  44.    warning" :STRUCT - Previous :STRUCT or :CLASS unfinished!"
  45.    ob_def_struct ob-state !     ( set pair flags )
  46. \
  47. \ Create new struct defining word.
  48.   CREATE
  49.       here ob-current-class !  ( set current )
  50.       0 ,        ( initial ivar offset )
  51.       0 ,        ( location for #byte to last )
  52.    DOES>  <:STRUCT>
  53. ;
  54.  
  55. : ;STRUCT ( -- , terminate structure )
  56.    ob-state @ ob_def_struct = NOT
  57.    IF " ;STRUCT - Missing :STRUCT above!" $error
  58.    THEN
  59.    false ob-state !
  60.  
  61. \ Point to last member.
  62.    latest ob-current-class @ -  ( byte difference )
  63.    ob-current-class @ cell+ !
  64. \
  65. \ Even up byte offset in case last member was BYTE.
  66.    ob-current-class @ dup @ even-up swap !
  67. ;
  68.  
  69. : DUP128<  ( n1 -- n1 flag )
  70.   dup  $ 80  <
  71. ;
  72.  
  73. \ Member reference words.
  74. : ..   ( object <member> -- member_address , calc addr of member )
  75.     ob.stats? drop state @
  76.     IF   \ [compile] literal compile +
  77.          ?dup
  78.          IF   $ 0687 w,  ,
  79.          THEN
  80.     ELSE +
  81.     THEN
  82. ; immediate
  83.  
  84. hex
  85. : 32@+BYTE \ move.l $x(org,tos.l),tos
  86.     [ 2e34,7800 ,                         ( -1 c! ) ]  inline ;
  87. : 32@+LONG \ add.l #x,tos  move.l $0(org,tos.l,tos)
  88.     [ 0687 w, 0 , 2e34,7800 ,             ( -8  ! ) ]  inline ;
  89.  
  90. \ These are for S@ and S!
  91. : (IF>REL)  ( -- , these must follow a MOVE to TOS )
  92. \ CCR must already be set
  93. \    beq @1
  94.     [ 6702 w,
  95. \    sub.l org,tos  @1
  96.       9E8C w, ]  inline ;
  97.  
  98. : 16U@+byte [ 7000,3034 , 7800,2e00 ,             ( -3 c! ) ]  inline ;
  99. : 16U@+long [ 0687 w, 0 , 7000,3034 , 7800,2e00 , ( -12 ! ) ]  inline ;
  100. : 8U@+byte  [ 7000,1034 , 7800,2e00 ,             ( -3 c! ) ]  inline ;
  101. : 8U@+long  [ 0687 w, 0 , 7000,1034 , 7800,2e00 , ( -12 ! ) ]  inline ;
  102.  
  103. \ Since these are signed they don't need a zeroed D0
  104. : 16@+byte \ move.w $x(org,tos.l),tos ext.l
  105.     [ 3e34,7800 , 48c7 w,                  ( -3 c! ) ]  inline ;
  106. : 16@+long [ 0687 w, 0 , 3e34,7800 , 48c7 w,      ( -10  ! ) ]  inline ;
  107. : 8@+byte  [ 1e34,7800 , 4887 w, 48c7 w,          ( -5 c! ) ]  inline ;
  108. : 8@+long  [ 0687 w, 0 , 1e34,7800 , 4887 w, 48c7 w, ( -12 ! ) ]  inline ;
  109.  
  110. : 32!+byte [ 299e,7800 , 2e1e w,                 ( -3 c! ) ]  inline tail ;
  111. : 32!+long [ 0687,0000 , 0000,299e , 7800,2e1e , ( -10 ! ) ]  inline tail ;
  112. : 16!+byte [ 39ae,0002 , 7800,588e , 2e1e w,     ( -5 c! ) ]  inline tail ;
  113. : 16!+long [ 0687,0000 , 0000,39ae , 0002,7800 ,
  114.                                      588e,2e1e , ( -14 ! ) ]  inline tail ;
  115. : 8!+byte  [ 19ae,0003 , 7800,588e , 2e1e w,     ( -5 c! ) ]  inline tail ;
  116. : 8!+long  [ 0687,0000 , 0000,19ae , 0003,7800 ,
  117.                                      588e,2e1e , ( -14 ! ) ]  inline tail ;
  118.  
  119. \ These do an IF>ABS before storing into structure.
  120. : >ABS32!+BYTE  ( -- , OFFSET -3)
  121.   [ 
  122.    201E W,         \  move.l  (dsp)+,d0 
  123.    6700 W, 0004 W, \  beq.l   $490B2   
  124.    D08C W,         \  add.l   org,D0
  125.    2980 W, 7800 W, \  move.l  d0,$0(org,tos.l)
  126.    2E1E W,         \  move.l  (dsp)+,tos
  127.   ] INLINE TAIL
  128. ;
  129.  
  130. : >ABS32!+LONG  ( -- , OFFSET -10 )
  131.   [
  132.    201E W,         \  move.l  (dsp)+,d0 
  133.    6700 W, 0004 W, \  beq.l   $490B2   
  134.    D08C W,         \  add.l   org,D0
  135.    0687 W, 0 ,     \  add.l   #$0,tos  ( OVERWRITE HERE )
  136.    2980 W, 7800 W, \  move.l  d0,$0(org,tos.l)
  137.    2E1E W,         \  move.l  (dsp)+,tos
  138.   ] INLINE TAIL
  139. ;
  140.  
  141. decimal
  142.  
  143. variable OB-CFA-B
  144. variable OB-CFA-POKE-B
  145. variable OB-CFA-L
  146. variable OB-CFA-POKE-L
  147. variable OB-CFA-0
  148.  
  149. : OB.COMPILE.+@/! ( offset cfa-b poke-b cfa-l poke-l cfa-0 -- )
  150.     ob-cfa-0 !
  151.     ob-cfa-poke-l ! ob-cfa-l !
  152.     ob-cfa-poke-b ! ob-cfa-b !
  153.     dup128<
  154.     IF  ?dup
  155.         IF ob-cfa-b @ cfa, here ob-cfa-poke-b @ - c!
  156.         ELSE ob-cfa-0 @ cfa,
  157.         THEN
  158.     ELSE ob-cfa-l @ cfa, here ob-cfa-poke-l @ - !
  159.     THEN
  160. ;
  161.  
  162. : !BYTES ( value address size -- )
  163.     CASE
  164.     cell OF ! ENDOF
  165.       -4 OF swap if>abs swap ! ENDOF
  166.   ABS  2 OF w! ENDOF
  167.        1 OF c! ENDOF
  168.        " ..! -  Not 1,2 4 or -4 bytes!" $error
  169.     ENDCASE
  170. ;
  171.  
  172. : COMPILE+!BYTES ( [ value address ] offset size -- )
  173.     CASE
  174.        4 OF ' 32!+byte 3 ' 32!+long 10 ' !
  175.             ob.compile.+@/!
  176.          ENDOF
  177.        -4 OF ' >abs32!+byte 3 ' >abs32!+long 10 ' >abs32!+LONG
  178.             ob.compile.+@/!
  179.          ENDOF
  180.      ABS
  181.        2 OF ' 16!+byte 5 ' 16!+long 14 ' w!
  182.             ob.compile.+@/!
  183.          ENDOF
  184.        1 OF ' 8!+byte  5 '  8!+long 14 ' c!
  185.             ob.compile.+@/!
  186.          ENDOF
  187.        " ..! -  Not 1,2 or 4 or -4 bytes!" $error
  188.     ENDCASE
  189. ;
  190.  
  191. \ These provide ways of setting and reading members values
  192. \ without knowing their size in bytes.
  193. : ..! ( value object <member> -- , store value in member )
  194.     ob.stats?
  195.     dup -4 =    \ ..@ does not use automatic >REL
  196.     IF drop 4
  197.     THEN
  198.     state @
  199.     IF  compile+!bytes 
  200.     ELSE ( -- value obj off size )
  201.         >r + r> !bytes
  202.     THEN
  203. ; immediate
  204.  
  205. \ Automatically convert addresses to absolute.
  206. : S! ( value object <member> -- , store value in member w/ >ABS )
  207.     ob.stats?
  208.     state @
  209.     IF  compile+!bytes 
  210.     ELSE ( -- value obj off size )
  211.         >r + r> !bytes
  212.     THEN
  213. ; immediate
  214.  
  215. variable SIGNED-MEMBERS  ( if true, sign extend signed members )
  216. signed-members ON  ( default )
  217.  
  218.  
  219. : @BYTES ( addr +/-size -- value )
  220.     CASE
  221.        4 OF @  ENDOF
  222.       -4 OF @ if>rel ENDOF
  223.        2 OF w@      ENDOF
  224.        1 OF c@      ENDOF
  225.       -2 OF w@ w->s     ENDOF
  226.       -1 OF c@ b->s     ENDOF
  227.        " ..@ -  Not 1,2 or 4 bytes!" $error
  228.     ENDCASE
  229. ;
  230.  
  231. : COMPILE+@BYTES ( [ value address ] offset +/-size -- )
  232.     signed-members @ 0=
  233.     IF ABS  ( ignore sign of member )
  234.     THEN
  235.     CASE
  236.        4 OF ' 32@+byte  1 ' 32@+long   8 ' @
  237.             ob.compile.+@/!
  238.          ENDOF
  239.        -4 OF ' 32@+byte  1 ' 32@+long   8 ' @
  240.             ob.compile.+@/!
  241.             compile (if>rel)
  242.          ENDOF
  243.        2 OF ' 16u@+byte 3 ' 16u@+long 12 ' 16u@+byte
  244.             ob.compile.+@/!
  245.          ENDOF
  246.        1 OF ' 8u@+byte  3 ' 8u@+long  12 ' 8u@+byte
  247.             ob.compile.+@/!
  248.          ENDOF
  249.       -2 OF ' 16@+byte  3 ' 16@+long  10 ' 16@+byte \ !!
  250.             ob.compile.+@/!
  251.          ENDOF
  252.       -1 OF ' 8@+byte   5 ' 8@+long   12 ' 8@+byte \ !!
  253.             ob.compile.+@/!
  254.          ENDOF
  255.        " COMPILE@BYTES -  Not 1,2 , -1,-2 or 4 bytes!" $error
  256.     ENDCASE
  257. ;
  258.  
  259. : ..@ ( object <member> -- value , fetch value from member )
  260.     ob.stats?
  261.     dup -4 =    \ ..@ does not use automatic >REL
  262.     IF drop 4
  263.     THEN
  264.     state @
  265.     IF compile+@bytes
  266.     ELSE >r + r> @bytes
  267.     THEN
  268. ; immediate
  269.  
  270. \ Automatically convert absolute addresses
  271. : S@ ( object <member> -- value , fetch value from member, >REL )
  272.     ob.stats?
  273.     state @
  274.     IF compile+@bytes
  275.     ELSE >r + r> @bytes
  276.     THEN
  277. ; immediate
  278.  
  279. \ These are aliases for use in reading AMIGA .J files.
  280. : | ( n m -- n|m , for easy AMIGA calls )
  281.    OR
  282. inline ;
  283.  
  284. : << ( n m -- n<<m , shift left n by m )
  285.    ashift
  286. ;
  287.  
  288. \ NULL pointer for 'C'
  289. 0 constant NULL
  290.  
  291. \ Allocate a structure, state sensitive
  292. : (ALLOCSTRUCT)  ( size -- addr | 0 , allocate clear )
  293.     memf_clear swap allocblock
  294. ;
  295.  
  296. : ALLOCSTRUCT ( <structure> -- , allocate a structure )
  297.     [compile] sizeof()
  298.     state @
  299.     IF compile (allocstruct)
  300.     ELSE (allocstruct)
  301.     THEN
  302. ; immediate
  303.  
  304. : RECARRAY 
  305.     CREATE ( many bytes/record <name> -- )
  306.         dup , * allot
  307.     DOES> ( index base -- addr )
  308.         tuck @ * + cell+
  309. ;
  310.  
  311. : ARRAYOF  ( many <structure> <name> -- )
  312.     [compile] sizeof()
  313.     recarray
  314. ;
  315.  
  316.